home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / CorePackages / prompts.tcl < prev    next >
Encoding:
Text File  |  2001-02-07  |  16.6 KB  |  518 lines
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  AlphaTcl - core Tcl engine
  4.  # 
  5.  #  FILE: "prompts.tcl"
  6.  #                                    created: 27/1/98 {11:14:34 am} 
  7.  #                                last update: 2/7/2001 {9:28:59 PM} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <vince@santafe.edu>
  10.  #    mail: 317 Paseo de Peralta
  11.  #          Santa Fe, NM 87501, USA
  12.  #     www: <http://www.santafe.edu/~vince/>
  13.  #  
  14.  # Copyright (c) 1998-2000  Vince Darley
  15.  # 
  16.  # See the file "license.terms" for information on usage and redistribution
  17.  # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  18.  # 
  19.  # General purpose status-line completion procedures.  Currently
  20.  # used by Tcl, TeX and Bib modes.  Will go in Alpha's 'CorePackages'
  21.  # directory with the next patch release.
  22.  # 
  23.  # Also contains a set of procedures for prompting the user
  24.  # for _small_ pieces of information, with validation of type
  25.  # for values entered.
  26.  # ###################################################################
  27.  ##
  28.  
  29. # auto-loading extension.
  30. alpha::extension prompts 0.1.2 {} help {
  31.     General purpose status-line completion procedures.  Currently
  32.     used by Tcl, TeX and Bib modes.  Also contains a set of
  33.     procedures for prompting the user for _small_ pieces of
  34.     information, with validation of type for values entered.
  35. }
  36.  
  37. namespace eval prompt {}
  38.  
  39. proc prompt::general {msg def} {
  40.     global useStatusBar
  41.     if {$useStatusBar} {
  42.     if {[catch {statusPrompt "$msg ($def): "} ans]} {
  43.         error "cancel"
  44.     }
  45.     if {![string length $ans]} {return $def}
  46.     return $ans
  47.     } else {
  48.     return [prompt $msg $def]
  49.     }
  50. }
  51.  
  52. # ◊◊◊◊ Status line completion ◊◊◊◊ #
  53.  
  54. ## 
  55.  # -------------------------------------------------------------------------
  56.  # 
  57.  # "prompt::fromChoices" --
  58.  # 
  59.  #  Prompt the user, with completion, for one item out of a given list. 
  60.  #  The list can either be explicit (-list items), derived from a command
  61.  #  (-command cmdReturnsList), or in a variable (-variable listvar).
  62.  #  
  63.  # -------------------------------------------------------------------------
  64.  ##
  65. proc prompt::fromChoices {msg def type choices} {
  66.     global useStatusBar
  67.     if {$useStatusBar} {
  68.     return [prompt::statusLineComplete $msg \
  69.       [list completion::fromChoices $type $choices] -default $def]
  70.     } else {
  71.     return [listpick -p $msg -L $def [completion::getChoices $type $choices]]
  72.     } 
  73. }
  74.  
  75. ## 
  76.  # -------------------------------------------------------------------------
  77.  # 
  78.  # "prompt::statusLineComplete" --
  79.  # 
  80.  #  Optional flags this proc can take
  81.  #  
  82.  #  -nobackup             : can't use left-arrow to remove a char
  83.  #  -nocache              : don't cache the list of completions 
  84.  #  -nomatchiserror       : if nothing matches, we abort
  85.  #  -initialpatt <string> : start with this string
  86.  #  -preeval <script>     : evaluate this script first at global scope
  87.  #  -posteval <script>    : evaluate this script afterwards at global scope
  88.  #  -tryuppercase         : if we have no matches, check if the user was
  89.  #                        : too lazy to use the shift key!
  90.  # -------------------------------------------------------------------------
  91.  ##
  92. proc prompt::statusLineComplete {what completeWith args} {
  93.     global __keysSoFar __startIndex __lastMatchesDisplayed __lastMatches \
  94.       __oldCurr
  95.     set __keysSoFar {}
  96.     set __startIndex 0
  97.     set __lastMatchesDisplayed {}
  98.     set __oldCurr ""
  99.     
  100.     catch {unset __lastMatches}
  101.     
  102.     message ""
  103.     set patt ""
  104.     
  105.     getOpts [list -preeval -posteval -initialpatt -default]
  106.     if {[info exists opts(-initialpatt)]} {
  107.     set patt $opts(-initialpatt)
  108.     }
  109.     set pos [getPos]
  110.     
  111.     if {[info exists opts(-preeval)]} {
  112.     catch {uplevel \#0 $opts(-preeval)}
  113.     }
  114.     if {[info exists opts(-default)]} {
  115.     set pr "${what} ($opts(-default)): $patt"
  116.     } else {
  117.     set pr "${what}: $patt"
  118.     }
  119.     catch {status::prompt -f -appendvar patt -command prompt::_complete -add anything $pr}
  120.     if {[info exists opts(-posteval)]} {
  121.     catch {uplevel \#0 $opts(-posteval)}
  122.     }
  123.     catch {unset __lastMatches}
  124.     # we're done
  125.     if {[info exists __completed]} {
  126.     return $__completed
  127.     }
  128.     message "Aborted: $patt"
  129.     goto $pos
  130.     error "Aborted: $patt"
  131. }
  132.  
  133. ## 
  134.  # -------------------------------------------------------------------------
  135.  # 
  136.  # "prompt::_complete" --
  137.  # 
  138.  # Summary: 
  139.  # 
  140.  #      Hit 'space' or 'return' or '1' to hit the first completion in
  141.  # the list, 2-9 to select subsequent ones, 'tab' to scroll the list,
  142.  # or any character to complete further.  Hit 'left-arrow' to delete
  143.  # a character from the current entry.  You can also use 'delete' to
  144.  # delete a character, except it's not shown in the display until you
  145.  # add a character.  This is a limitation of Alpha.
  146.  # 
  147.  # Details:
  148.  # 
  149.  #  The mods to this proc are along the lines of the proc that provides 
  150.  #  acronym-epansion in latex. Here you just type and get a list in the 
  151.  #  statusline of all the commands known to tcl that start with whatever 
  152.  #  you have typed so far. Whenever the set of commands share a common 
  153.  #  prefix that goes beyond what you have typed the "letters-entered" 
  154.  #  portion of the statusline advances to include all the common letters 
  155.  #  (this means you have to be careful you don't re-enter them manually, as 
  156.  #  that will likely abort entry as no command will match).
  157.  #  
  158.  #  Once you have started entering characters, you are presented with the 
  159.  #  number of known cammands that start with those characters followed by 
  160.  #  a horizontal listing of as many of those commands that will fit on the 
  161.  #  line. These commands are separated by double spaces in order to make 
  162.  #  commands stand out as a whole to the eye (command with "::" in them 
  163.  #  are harder for the eyes to parse without this).
  164.  #  
  165.  #  At this point you either keep entering characters to narrow the matching 
  166.  #  commands, type a tab to scroll through the horizontal list, or type a 
  167.  #  numeral that corresponds to the position one of the visible commands in 
  168.  #  the horizontal list (which will then be looked-up).
  169.  #  
  170.  #  If you just keep entering characters till you narrow the list to one 
  171.  #  command, you might get down to a situation where the command you want 
  172.  #  out of the matches is contained in all the other matches. When this 
  173.  #  happens all you have to do is to type a <space> and you will look-up 
  174.  #  that command.
  175.  #  
  176.  #  To make things easier, whenever a character is entered that would abort 
  177.  #  the procedure, it is first checked to see if the upperCase version of 
  178.  #  tht character would not keep us for aborting. For example, if you had 
  179.  #  'page…' as the entered portion, your list would be: 
  180.  #  (pageBackward  pageForward  pageSetup), so entering 'B' or 'b' would 
  181.  #  lookup pageBackward for you.
  182.  #  
  183.  #  ToDo: 
  184.  #  • provide cushioning/alerting mechanism against aborting when the user 
  185.  #  does not notice that entered portion has been automatically extended. 
  186.  #  Perhaps, flash the statusline and color the automatically entered 
  187.  #  portion, and/or allow the rentering of the auto-entered portion. 
  188.  #  Of course insertColorEscape does not work in the statusline, but 
  189.  #  perhaps it would be possible figure out the escapes and enter them 
  190.  #  as literals via message.
  191.  #  • perhaps alter this so you have the option of deleting characters 
  192.  #  instead of aborting when you get no matches.
  193.  #  • perhaps provide a variant that inserts the found procName into your 
  194.  #  current cursor position instead of doing a look-up.
  195.  #  
  196.  #  Note: made one change, moved the "number found:" portion of the prompt 
  197.  #  outside the horizontal list so it is easy to visually parse the list 
  198.  #  to determine what nember to hit to make a choice from the list.
  199.  #  
  200.  #  Author: mostly Tom Fetherston; Vince made the proc a little more
  201.  #  general so it is now used by C++, Tcl and Bib modes.
  202.  # -------------------------------------------------------------------------
  203.  ##
  204. proc prompt::_complete {{key 0} {mod 0}} {
  205.     global __keysSoFar __startIndex __lastStartIndex __lastMatchesDisplayed
  206.     global __oldCurr
  207.  
  208.     # Don't want this anymore
  209.     # if {$mod && ($mod != 2)} {error ""}
  210.     upvar opts opt
  211.     upvar patt pat
  212.     upvar completeWith compP
  213.     upvar what whatP
  214.     if {![info exists opt(-nocache)]} {
  215.     global __lastMatches
  216.     }
  217.     set curr $pat
  218.     if {$__oldCurr != "" && ([string length $__oldCurr] >= [string length $curr])} {
  219.     # we've used delete (Alpha just deletes without telling us)
  220.     set real_key $key
  221.     set remove [expr {1 + [string length $__oldCurr] - [string length $curr]}]
  222.     regsub {.$} $curr "" __oldCurr
  223.     set key "\034"
  224.     } else {
  225.     set __oldCurr $curr
  226.     }
  227.     switch -regexp -- $key {
  228.     "\t" {
  229.         set __lastStartIndex $__startIndex 
  230.         if {![info exists __lastMatches]} {
  231.         set __lastMatches [lsort [eval $compP [list $pat]]]
  232.         }
  233.         set msg "$whatP '$pat…' ($__lastMatches)"
  234.         if {[string length $msg] > 80} {
  235.         set numFound [llength $__lastMatches]
  236.         set nextIdx [expr {$__startIndex + 1}]
  237.         set msg "$whatP '$pat…' $numFound found: ([lindex $__lastMatches $__startIndex] … »tab"
  238.         while {($nextIdx < $numFound) && ([string length "$msg  [lindex $__lastMatches $nextIdx]"] <= 80)} {
  239.             set matchesDisplayed [lrange $__lastMatches $__startIndex $nextIdx]
  240.             incr nextIdx
  241.             if {$nextIdx >= $numFound} {
  242.             set more ""
  243.             } else {
  244.             set more "…"
  245.             } 
  246.             if {$__startIndex == 0} {
  247.             set start ""
  248.             } else {
  249.             set start "…"
  250.             } 
  251.             set msg "$whatP '$pat…' $numFound found: ($start $matchesDisplayed $more) »tab"
  252.         }
  253.         if {$nextIdx >= [expr {$numFound}]} {
  254.             set __lastStartIndex $__startIndex 
  255.             set __startIndex 0
  256.         } else {
  257.             set __lastStartIndex $__startIndex 
  258.             set __startIndex [expr {$nextIdx}]
  259.         }
  260.         }
  261.         message $msg
  262.         set __lastMatchesDisplayed $matchesDisplayed
  263.         return " "
  264.     }
  265.     " " - "\r" {
  266.         if {![llength $__lastMatchesDisplayed] && [info exists opt(-default)]} {
  267.         set __lastMatches $opt(-default)
  268.         } else {
  269.         set __lastMatches [lindex $__lastMatchesDisplayed 0]
  270.         }
  271.     }
  272.     "\[\034\035\036\037\]" {
  273.         if {![info exists opt(-nobackup)] && $key == "\034"} {
  274.         set __keysSoFar $pat
  275.         set oldNumFound [llength $__lastMatches]
  276.         set numFound $oldNumFound
  277.         if {![info exists remove]} {set remove 1}
  278.         # make sure we remove enough chars so that we
  279.         # actually add some more choices!
  280.         while {$remove > 0 || ($numFound <= $oldNumFound && $__keysSoFar != "")} {
  281.             set __keysSoFar [string range $__keysSoFar 0 [expr {[string length $__keysSoFar] -2}]]
  282.             set __lastMatches [eval $compP [list $__keysSoFar]]
  283.             set numFound [llength $__lastMatches]
  284.             incr remove -1
  285.         }
  286.         set __lastMatches [lsort $__lastMatches]
  287.         set pat $__keysSoFar
  288.         if {[info exists real_key]} {
  289.             uplevel 1 [list prompt::_complete $real_key]
  290.         }
  291.         } else {
  292.         error ""
  293.         }
  294.     }
  295.     default {
  296.         # here we rely on left-to-right evaluation
  297.         if {![llength [set __lastMatches [prompt::_updateLastMatches $compP $__keysSoFar$key]]] \
  298.           && [regexp {[1-9]} $key]} {
  299.         # we hit 1-9 and are trying to select that item in 
  300.         # the list displayed
  301.         if {$key <= [llength $__lastMatchesDisplayed]} {
  302.             set __lastMatches [lindex "null $__lastMatchesDisplayed" $key]
  303.         } else {
  304.             error ""
  305.         }                 
  306.         }
  307.         # otherwise we already did all we needed in the first part
  308.         # of the 'if' statement.
  309.     }
  310.     }
  311.     
  312.     set numFound [llength $__lastMatches]
  313.     if {!$numFound} {
  314.     # first we'll see if the user was just too lazy to shift the key
  315.     if {[info exists opt(-tryuppercase)]} {
  316.         set __lastMatches [prompt::_updateLastMatches $compP $__keysSoFar[string toupper $key]]
  317.         set numFound [llength $__lastMatches]
  318.     }
  319.     } 
  320.     append __keysSoFar $key
  321.     set pat $__keysSoFar
  322.     switch $numFound {
  323.     0 {
  324.         if {![info exists opt(-nomatchiserror)]} {
  325.         message "$whatP '$pat…' NO MATCHES!!"
  326.         return " "
  327.         } else {
  328.         error "No matches"
  329.         }
  330.     }
  331.     1 {
  332.         set pat $__lastMatches
  333.         message "$whatP -- '$pat'"
  334.         upvar __completed c
  335.         set c $pat
  336.         error "done"
  337.     }
  338.     }
  339.     set pat [largestPrefix $__lastMatches]
  340.     set __keysSoFar $pat
  341.     set matchesDisplayed $__lastMatches
  342.     set msg "$whatP '$pat…' ($matchesDisplayed)"
  343.     if {[string length $msg] > 80} {
  344.     set matchesDisplayed [lindex $__lastMatches 0]
  345.     set nextIdx 1
  346.     set msg "$whatP '$pat…' $numFound found: ($matchesDisplayed …) »tab"
  347.     while {($nextIdx < $numFound) && ([string length "$msg [lindex $__lastMatches $nextIdx]"] <= 80)} {
  348.         append matchesDisplayed "  " [lindex $__lastMatches $nextIdx]
  349.         incr nextIdx
  350.         set msg "$whatP '$pat…' $numFound found: ($matchesDisplayed …) »tab"
  351.     }
  352.     if {$nextIdx > [expr {$numFound}]} {
  353.         set __lastStartIndex $__startIndex 
  354.         set __startIndex 0
  355.     } else {
  356.         set __lastStartIndex $__startIndex 
  357.         set __startIndex [expr {$nextIdx -1}]
  358.     }
  359.     
  360.     } 
  361.     set __lastMatchesDisplayed $matchesDisplayed
  362.     message $msg 
  363.     return " "
  364. }
  365.  
  366. proc prompt::_updateLastMatches {compP str} {
  367.     global __lastMatches
  368.     if {![info exists __lastMatches]} {
  369.     set res [lsort [eval $compP $str]] 
  370.     } else {
  371.     set res [completion::fromList $str __lastMatches]
  372.     }
  373.     if {[info exists __lastMatches]} {
  374.     set __lastMatches $res
  375.     } 
  376.     return $res
  377. }
  378.  
  379. # ◊◊◊◊ Simple dialogs/prompts ◊◊◊◊ #
  380.  
  381. ## 
  382.  # -------------------------------------------------------------------------
  383.  # 
  384.  # "prompt::var" --
  385.  # 
  386.  #  Ask for value for a single variable.  Forces calling proc to return
  387.  #  if value isn't ok, or procedure is cancelled.
  388.  # -------------------------------------------------------------------------
  389.  ##
  390. proc prompt::var {prompt var {def ""} {testproc ""} {desired 1} {errmsg ""}} {
  391.     global promptNoisily useStatusBar
  392.     if {$promptNoisily && $useStatusBar} {beep}
  393.     upvar $var vvar
  394.     if {$useStatusBar} {
  395.     if {[catch {statusPrompt "$prompt ($def): "} vvar]} {
  396.         return -code return
  397.     }
  398.     if {![string length $vvar]} {
  399.         set vvar $def
  400.     }
  401.     } else {
  402.     if {[catch {prompt $prompt $def} vvar]} {
  403.         return -code return
  404.     }
  405.     }
  406.     if {$testproc != ""} {
  407.     if {[$testproc $vvar] != $desired} {
  408.         beep
  409.         message $errmsg
  410.         return -code return
  411.     }
  412.     }
  413. }
  414.  
  415. ## 
  416.  # -------------------------------------------------------------------------
  417.  # 
  418.  # "prompt::simple" --
  419.  # 
  420.  #  Prompt for a few variable values, with entry-validation.  Example
  421.  #  usage:
  422.  #  
  423.  #      prompt::simple \
  424.  #        [list "how many rows?" numberRows 2 N] \
  425.  #          [list "how many columns?" numberColumns 2 N]
  426.  #
  427.  #  Which either throws an error, or ensures the variables 'numberRows'
  428.  #  'numberColumns' are set to Natural numbers, with defaults of '2'.
  429.  # -------------------------------------------------------------------------
  430.  ##
  431. proc prompt::simple {args} {
  432.     set i 0
  433.     set y 40
  434.     set dialog ""
  435.     while 1 {
  436.     set v [lindex $args $i]
  437.     if {[llength $v] <= 1} {
  438.         set args [lrange $args $i end]
  439.         break
  440.     }
  441.     upvar [lindex $v 1] _v$i
  442.     lappend dialog "-t" [lindex $v 0] 10 $y 180 [expr {$y + 18}] \
  443.       -e [lindex $v 2] 220 $y 240 [expr {$y + 18}]
  444.     incr y 30
  445.     set _check$i [lrange $v 3 end]
  446.     incr i
  447.     }
  448.     # now args contains just the options
  449.     getOpts {-title}
  450.     if {[info exists opts(-title)]} {
  451.     set title [list -t $opts(-title) 20 10 440 30]
  452.     } else {
  453.     set title [list -t "Please enter the following:" 20 10 440 30]
  454.     }
  455.     set buttons [dialog::okcancel 50 y]
  456.     set res [eval [concat dialog -w 480 -h $y $title \
  457.       $buttons $dialog]]
  458.     if {[lindex $res 1]} { error "Cancel" }
  459.     for {set j 0} {$j < $i} {incr j} {
  460.     set _v$j [string trim [lindex $res [expr {2+$j}]]]
  461.     if {[set _check$j] != ""} {
  462.         eval entry::validate [list [set _v$j]] [set _check$j] 
  463.     }
  464.     }
  465.     return
  466. }
  467.  
  468. namespace eval entry {}
  469.  
  470. ## 
  471.  # -------------------------------------------------------------------------
  472.  # 
  473.  # "entry::validate" --
  474.  # 
  475.  #  Check if {$val} is of the given type, if the type is unrecognised, it
  476.  #  is assumed to be a procedure we call, and check if the result of
  477.  #  that procedure is either 1 or the first element of args if such
  478.  #  an element was given.
  479.  #  
  480.  #  Therefore
  481.  #  
  482.  #    entry::validate $x Z
  483.  #    entry::validate $x is::Integer
  484.  #    entry::validate $x is::Integer 1
  485.  #    
  486.  #  are all equivalent.
  487.  # -------------------------------------------------------------------------
  488.  ##
  489. proc entry::validate {val type args} {
  490.     switch -- $type {
  491.     "N" - "Z+" {
  492.         if {![is::PositiveInteger $val]} {
  493.         dialog::errorAlert "invalid input '$val':  unsigned, positive integer required"
  494.         }
  495.     }
  496.     "Z" {
  497.         if {![is::Integer $val]} {
  498.         dialog::errorAlert "invalid input '$val':  integer required"
  499.         }
  500.     }
  501.     "bool" {
  502.     }
  503.     "R" {
  504.         if {![is::Numeric $val]} {
  505.         dialog::errorAlert "invalid input '$val':  real number required"
  506.         }
  507.     }
  508.     default {
  509.         set check [eval $type [list $val]]
  510.         if {$check != [expr {[llength $args] == 0 ? 1 : [lindex $args 0]}]} {
  511.         dialog::errorAlert "invalid input '$val'"
  512.         }
  513.     }
  514.     }
  515. }
  516.  
  517.  
  518.